home *** CD-ROM | disk | FTP | other *** search
/ CD Ware Multimedia 1995 May / cd Ware (Juegos) Epimundo.iso / DOS / PRGMMING / DDPLUS67.ZIP / MISC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-11-21  |  9.1 KB  |  292 lines
  1. (********************************)
  2. (*   Programming:  Bob Dalton   *)
  3. (*   Misc Utilities-Vers 1.00   *)
  4. (*   Utility Module             *)
  5. (********************************)
  6.  
  7. UNIT Misc;
  8.  
  9. INTERFACE
  10.  
  11. Uses Crt,Dos,DDPlus;
  12.  
  13. FUNCTION ShareInst : boolean;
  14. FUNCTION File_Exists(Filename: string ): boolean;
  15. PROCEDURE Terminate (N:Byte);
  16. PROCEDURE TrapExit;
  17. PROCEDURE MyExit1;
  18.  
  19. IMPLEMENTATION   (********************************)
  20.  
  21. {This unit cannot be overlayed}
  22.  
  23. function ShareInst : boolean;
  24. const FCT_SHARE    = $1000;                  { Install text for Share }
  25.       MULTIPLEX    = $2F;                       { Multiplex interrupt }
  26.       NE_OK        = $00;                              { No error }
  27. var regs   : registers;      { Processor registers for interrupt call }
  28.     NetError : integer;             { Error number from DOS interrupt }
  29. begin
  30.  regs.ax := FCT_SHARE;                     { Test for installed Share }
  31.  intr( MULTIPLEX, regs );                  { Call multiplex interrupt }
  32.  ShareInst := ( regs.al = $FF );                      { Return result }
  33.  NetError := NE_OK;                                        { No error }
  34. end;
  35.  
  36. FUNCTION File_Exists(Filename: string ): boolean;
  37. {returns true if file exists}
  38. var Inf: SearchRec;
  39. begin
  40.     findfirst(Filename,AnyFile,Inf);
  41.     File_Exists := (DOSError = 0);
  42. end;  {func Exist}
  43.  
  44. PROCEDURE Terminate (N:Byte);
  45.  Begin
  46.    CASE N OF
  47.      0:SWriteln('Normal Termination');
  48.      1:Begin SWriteln('Carrier lost'); End;
  49.      2:Begin SWriteln('*** TIME LIMIT HAS EXPIRED ***'); End;
  50.      3:Begin SWriteln('User Inactive for 5+ minutes'); End;
  51.    End
  52.  End;
  53.  
  54. {$F+}
  55.  
  56. (* This exit procedure may be used to trap HALT codes.  If defined in the
  57.    main body of your program (DoorExit := TrapExit), this procedure will be
  58.    called whenever your program encounters a HALT code or runtime error.
  59.  
  60.    As shown below, if ErrorAddr <> NIL (no runtime error has occurred) the
  61.    runtime error information is displayed to the local console and is also
  62.    written to a file called PROG_ERR.LOG.  You may wish to change the name
  63.    of this error log file to something more fitting to your program.
  64.    If ErrorAddr = NIL then this code assumes that no runtime error has
  65.    occurred but rather that a HALT code has been encountered.  You could
  66.    conceivably handle all your HALT functions within the TRAPEXIT procedure.
  67.    However, in this demonstration, we can see that we are passing the HALT
  68.    code onto the TERMINATE procedure which is located within your program's
  69.    code.
  70. *)
  71.  
  72.  
  73. PROCEDURE TrapExit;
  74.  
  75. CONST
  76.    ProductName='GodFather of Crime Vers 1.23';
  77.  
  78. VAR
  79.    ErrFile    : TEXT ;
  80.    A1: Byte;
  81.    YE: Boolean;
  82.  
  83.  
  84.    FUNCTION Error_message(Code: Integer): STRING;
  85.       {return message text for a given runtime error code}
  86.    VAR
  87.       Class:  STRING;
  88.       Msg:    STRING;
  89.    BEGIN
  90.       CASE Code OF
  91.            1.. 99: Class := 'DOS ERROR      :';
  92.          100..149: Class := 'I/O ERROR      :';
  93.          150..199: Class := 'CRITICAL ERROR :';
  94.          200..249: Class := 'FATAL ERROR    :';
  95.          ELSE      Class := 'UNKNOWN ERROR  :';
  96.       END;
  97.  
  98.       CASE Code OF
  99.            2: Msg := 'File not found';
  100.            3: Msg := 'Path not found';
  101.            4: Msg := 'Too many open files';
  102.            5: Msg := 'File access denied';
  103.            6: Msg := 'Bad file handle';
  104.           12: Msg := 'Bad file access code';
  105.           15: Msg := 'Bad drive number';
  106.           16: Msg := 'Can''t remove current dir';
  107.           17: Msg := 'Can''t rename across drives';
  108.  
  109.          100: Msg := 'Disk read error, read past eof on Typed File';
  110.          101: Msg := 'Disk write error';
  111.          102: Msg := 'File not assigned';
  112.          103: Msg := 'File not open';
  113.          104: Msg := 'File not open for input';
  114.          105: Msg := 'File not open for output';
  115.          106: Msg := 'Bad numeric format';
  116.  
  117.          150: Msg := 'Disk is write-protected';
  118.          151: Msg := 'Unknown diskette unit';
  119.          152: Msg := 'Drive not ready';
  120.          153: Msg := 'Unknown command';
  121.          154: Msg := 'CRC error in data';
  122.          155: Msg := 'Bad drive request structure length';
  123.          156: Msg := 'Disk seek error';
  124.          157: Msg := 'Unknown diskette type';
  125.          158: Msg := 'Sector not found';
  126.          159: Msg := 'Printer out of paper';
  127.          160: Msg := 'Device write fault';
  128.          161: Msg := 'Device read fault';
  129.          162: Msg := 'Hardware failure';
  130.  
  131.          200: Msg := 'Division by zero';
  132.          201: Msg := 'Range check';
  133.          202: Msg := 'Stack overflow';
  134.          203: Msg := 'Heap overflow'+' (Not enough memory to run)';
  135.          204: Msg := 'Bad pointer operation';
  136.          205: Msg := 'Floating point overflow';
  137.          206: Msg := 'Floating point underflow';
  138.          207: Msg := 'Bad floating point operation';
  139.  
  140.          ELSE STR(Code,Msg);
  141.       END;
  142.  
  143.       Error_message := Class + Msg;
  144.    END;
  145.  
  146.    FUNCTION Exit_message(Code: Integer): STRING;
  147.       {return message text for a given exit code}
  148.    VAR
  149.       Msg:    STRING;
  150.    BEGIN
  151.       CASE Code OF
  152.            0: Msg := 'Normal Termination';
  153.            1: Msg := 'Carrier Lost';
  154.            2: Msg := 'Time Limit Exceeded';
  155.            3: Msg := 'User Inactivity Timeout';
  156.            4: Msg := 'Cannot Find Dorinfo1.def';
  157.            5: Msg := 'Cannot Find ExitInfo.Bbs';
  158.            6: Msg := 'Directory Change/Read Error';
  159.            7: Msg := 'CTS Timeout';
  160.            8: Msg := 'Forced Exit via RAXIT Semaphore';
  161.            9: Msg := 'Cannot Find Door.Sys';
  162.          ELSE STR(Code,Msg);
  163.       END;
  164.       Exit_Message := Msg;
  165.    END;
  166.  
  167.  
  168.    FUNCTION Itoh(W: Integer): STRING;
  169.       {hex conversion}
  170.    CONST
  171.       Hex: ARRAY[0..15] OF CHAR = '0123456789ABCDEF';
  172.    VAR
  173.       H: STRING[4];
  174.    BEGIN
  175.       H[0] := CHR(4);
  176.       H[1] := Hex[(W SHR 12) AND $0f];
  177.       H[2] := Hex[(W SHR  8) AND $0f];
  178.       H[3] := Hex[(W SHR  4) AND $0f];
  179.       H[4] := Hex[W          AND $0f];
  180.       Itoh := H;
  181.    END;
  182.  
  183. BEGIN
  184.    A1:=18;
  185.    YE:=False;
  186.    IF ErrorAddr = NIL THEN
  187.     Begin
  188.      If ExitCode = 0 then
  189.       Begin
  190.        Terminate(0) ;
  191.        Exit;
  192.       End;
  193.      IF ShareInst=False then FileMode:=64;
  194.      YE:=False;
  195.      ASSIGN(ErrFile,'ERROR.LOG');
  196.      IF FILE_EXISTS('ERROR.LOG') THEN
  197.       Begin
  198.        OpenAttempts:=1;
  199.        Repeat
  200.         {$I-}
  201.         Append(ErrFile);
  202.         {$I+}
  203.         GoAhead:= (IOResult = 0);
  204.         If Not GoAhead then OpenAttempts :=OpenAttempts+1;
  205.        Until (GoAhead) or (OpenAttempts>15);
  206.       End;
  207.      IF NOT FILE_EXISTS('ERROR.LOG') THEN
  208.       Begin
  209.        OpenAttempts:=1;
  210.        Repeat
  211.         {$I-}
  212.         Rewrite(ErrFile);
  213.         {$I+}
  214.         GoAhead:= (IOResult = 0);
  215.         If Not GoAhead then OpenAttempts :=OpenAttempts+1;
  216.        Until (GoAhead) or (OpenAttempts>15);
  217.       End;
  218.      If ProductName <> '' then
  219.       Begin
  220.        Writeln(ErrFile,'Error Log Generated by ',ProductName);
  221.        Writeln(ErrFile,' ');
  222.       End;
  223.      WRITELN('Date : ',Year,Month,Day);
  224.      WRITELN(' ');
  225.      WRITELN('Program Termination');
  226.      WRITELN(Exit_Message(Exitcode));
  227.      WRITELN(ErrFile,'Date : ',Year,Month,Day);
  228.      WRITELN(ErrFile,'Program Termination');
  229.      WRITELN(ErrFile,Exit_Message(Exitcode));
  230.      flush(ErrFile) ;
  231.      Close(ErrFile);
  232.      IF ShareInst=False then FileMode:=66;
  233.      Terminate(ExitCode);
  234.      Delay(1000);
  235.      End ELSE
  236.       BEGIN
  237.        ASSIGN(ErrFile,'ERROR.LOG');
  238.        IF FILE_EXISTS('ERROR.LOG') THEN
  239.         Begin
  240.          OpenAttempts:=1;
  241.          Repeat
  242.           {$I-}
  243.           Append(ErrFile);
  244.           {$I+}
  245.           GoAhead:= (IOResult = 0);
  246.           If Not GoAhead then OpenAttempts :=OpenAttempts+1;
  247.          Until (GoAhead) or (OpenAttempts>15);
  248.         End;
  249.        IF NOT FILE_EXISTS('ERROR.LOG') THEN
  250.         Begin
  251.          OpenAttempts:=1;
  252.          Repeat
  253.           {$I-}
  254.           Rewrite(ErrFile);
  255.           {$I+}
  256.           GoAhead:= (IOResult = 0);
  257.           If Not GoAhead then OpenAttempts :=OpenAttempts+1;
  258.          Until (GoAhead) or (OpenAttempts>15);
  259.         End;
  260.        WRITELN('Date : ',Year,Month,Day);
  261.        WRITELN('Run-time error occurred');
  262.        WRITELN('Exitcode = ', exitcode);
  263.        WRITELN(Error_Message(Exitcode));
  264.        WRITELN('Address of error:');
  265.        WRITELN('  Segment: ', ItoH(seg(erroraddr^)));
  266.        WRITELN('  Offset:  ', ItoH(ofs(erroraddr^))) ;
  267.        WRITELN(ErrFile,'Date : ',Year,Month,Day);
  268.        WRITELN(ErrFile,'Run-time error occurred');
  269.        WRITELN(ErrFile,'Exitcode = ', exitcode);
  270.        WRITELN(ErrFile,Error_Message(Exitcode));
  271.        WRITELN(ErrFile,'Address of error:');
  272.        WRITELN(ErrFile,'  Segment: ', ItoH(seg(erroraddr^)));
  273.        WRITELN(ErrFile,'  Offset:  ', ItoH(ofs(erroraddr^))) ;
  274.        WRITELN(ErrFile,'------------------------------------------------');
  275.        flush(ErrFile) ;
  276.        Close(ErrFile);
  277.        IF ShareInst=False then FileMode:=66;
  278.       END ;
  279.    ErrorAddr := NIL ;
  280.   END;
  281. {$F-}
  282.  
  283. {$F+} Procedure MyExit1; {$F-}
  284. VAR SaveExitProc: POINTER;
  285. Begin;
  286.  TrapExit;
  287.  SaveExitProc:=Exitproc;
  288. End;
  289.  
  290. END.
  291.  
  292.